home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / env / read-command.scm < prev    next >
Text File  |  1995-10-13  |  6KB  |  187 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Read a command.  No command name completion, yet.
  5.  
  6. (define (read-command prompt form-preferred? i-port)
  7.   (really-read-command prompt form-preferred? i-port no-more-commands))
  8.  
  9. (define (really-read-command prompt form-preferred? i-port more-commands)
  10.   (let ((o-port (command-output)))
  11.     (let prompt-loop ()
  12.       (if (and prompt (not (batch-mode?)))
  13.       (display prompt o-port))
  14.       (force-output o-port)        ;foo
  15.       (let loop ()
  16.         (let ((c (peek-char i-port)))
  17.           (cond ((eof-object? c)
  18.                  (read-char i-port))
  19.                 ((char-whitespace? c)
  20.                  (read-char i-port)
  21.                  (if (char=? c #\newline)
  22.                      (prompt-loop)
  23.                      (loop)))
  24.                 ((char=? c #\;)      ;Comment
  25.          (gobble-line i-port)
  26.          (prompt-loop))
  27.                 ((char=? c command-prefix)
  28.                  (read-char i-port)
  29.                  (read-named-command i-port more-commands form-preferred?))
  30.         ((or form-preferred?
  31.              (and (not (char-alphabetic? c))
  32.               (not (char-numeric? c))
  33.               (not (char=? c #\?))))
  34.          (read-evaluation-command i-port))
  35.         (else
  36.          (read-named-command i-port more-commands form-preferred?))))))))
  37.  
  38. (define (read-command-carefully prompt form-preferred? i-port . more-commands)
  39.   (call-with-current-continuation
  40.     (lambda (k)
  41.       (with-handler
  42.       (lambda (c punt)
  43.         (if (and (not (batch-mode?))
  44.              (or (read-error? c)
  45.              (read-command-error? c)))
  46.         (let ((port (last (condition-stuff c))))
  47.           (if (eq? port i-port)
  48.                       (do ()
  49.                           ((or (not (char-ready? port))
  50.                                (let ((c (read-char port)))
  51.                                  (or (eof-object? c) (char=? c #\newline)))))))
  52.           (display-condition c (command-output))
  53.           (k #f))
  54.         (punt)))
  55.     (lambda ()
  56.       (really-read-command prompt form-preferred? i-port
  57.                    (if (null? more-commands)
  58.                    no-more-commands
  59.                    (car more-commands))))))))
  60.  
  61. (define (read-evaluation-command i-port)
  62.   (let ((form (read-form i-port)))
  63.     (if (eq? (skip-over horizontal-space? i-port) #\newline)
  64.     (read-char i-port))
  65.     (make-command 'run (list form))))
  66.  
  67. (define (no-more-commands name)
  68.   #f)
  69.  
  70. ; Read a single form, allowing ## as a way to refer to last command
  71. ; output.
  72.  
  73. (define (read-form port)
  74.   (with-sharp-sharp (make-node (get-operator 'quote)
  75.                    (list 'quote (focus-object)))
  76.     (lambda () (read port))))
  77.  
  78. ; Read a command line:  <name> <arg> ... <newline>
  79.  
  80. (define (read-named-command port more-commands form-preferred?)
  81.   (let ((c-name (read port)))
  82.     (let ((syntax (or (more-commands c-name)
  83.               (get-command-syntax c-name))))
  84.       (cond (syntax
  85.          (make-command c-name
  86.                (read-command-arguments syntax #f port
  87.                            more-commands
  88.                            form-preferred?)))
  89.         (else
  90.          (read-command-arguments '(&rest form) #f port #f #f) ; flush junk
  91.          (write-line "Unrecognized command name." (command-output))
  92.          #f)))))
  93.  
  94. (define (read-command-arguments ds opt? port more-commands form-preferred?)
  95.   (let recur ((ds ds) (opt? opt?))
  96.     (let ((c (skip-over horizontal-space? port)))
  97.       (cond ((and (not (null? ds))
  98.           (eq? (car ds) '&opt))
  99.          (recur (cdr ds) #t))
  100.         ((or (eof-object? c)
  101.          (char=? c #\newline)
  102.          (if (char=? c #\;)    ;Comment
  103.                  (begin (gobble-line port)
  104.                     #t)
  105.                  #f))
  106.          (cond ((or (null? ds)
  107.                 (eq? (car ds) '&rest)
  108.                 opt?)
  109.             (read-char port)
  110.             '())
  111.                (else
  112.             (read-command-error port
  113.                         "too few command arguments"))))
  114.         ((null? ds)
  115.          (read-command-error port "too many command arguments"))
  116.         ((eq? (car ds) '&rest)
  117.          (let ((arg (read-command-argument (cadr ds) port)))
  118.            (cons arg (recur ds #f))))
  119.         ((eq? (car ds) 'command)    ; must be the last argument
  120.          (if (not (null? (cdr ds)))
  121.          (error "invalid argument descriptions" ds))
  122.          (list (really-read-command #f form-preferred? port more-commands)))
  123.         (else
  124.          (let ((arg (read-command-argument (car ds) port)))
  125.            (cons arg (recur (cdr ds) opt?))))))))
  126.  
  127. (define (read-command-argument d port)
  128.   (if (procedure? d)
  129.       (d port)
  130.       (case d
  131.     ((filename)
  132.      (read-string port char-whitespace?))
  133.     ((expression form)
  134.      (read-form port))
  135.     ((name)
  136.      (let ((thing (read port)))
  137.        (if (symbol? thing)
  138.            thing
  139.            (read-command-error port "invalid name" thing))))
  140.     (else (error "invalid argument description" d)))))
  141.  
  142. (define-condition-type 'read-command-error '(error))
  143. (define read-command-error? (condition-predicate 'read-command-error))
  144.  
  145. (define (read-command-error port message . rest)
  146.   (apply signal 'read-command-error message (append rest (list port))))
  147.  
  148.  
  149. ; Utilities.
  150.  
  151. (define (horizontal-space? c)
  152.   (and (char-whitespace? c)
  153.        (not (char=? c #\newline))))
  154.  
  155. (define (read-string port delimiter?)
  156.   (let loop ((l '()))
  157.     (let ((c (peek-char port)))
  158.       (cond ((or (eof-object? c)
  159.                  (delimiter? c))
  160.              (list->string (reverse l)))
  161.             (else
  162.              (loop (cons (read-char port) l)))))))
  163.  
  164. (define (skip-over pred port)
  165.   (let ((c (peek-char port)))
  166.     (cond ((eof-object? c) c)
  167.       ((pred c) (read-char port) (skip-over pred port))
  168.       (else c))))
  169.  
  170.  
  171.  
  172. ; ## should evaluate to the last REP-loop result.
  173. (define-sharp-macro #\#
  174.   (lambda (c port)
  175.     (read-char port)
  176.     ((fluid $sharp-sharp) port)))
  177.  
  178. (define $sharp-sharp
  179.   (make-fluid (lambda (port) (reading-error port "## in invalid context"))))
  180.  
  181. (define (with-sharp-sharp form body)
  182.   (let-fluid $sharp-sharp (lambda (port) form) body))
  183.  
  184. (define make-command cons)      ;(name . args)
  185.  
  186. ; (put 'with-sharp-sharp 'scheme-indent-hook 1)
  187.